home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.01 Jan 87 / scheme source / texteditor.sch < prev   
Encoding:
Text File  |  1986-11-25  |  9.0 KB  |  280 lines  |  [TEXT/EDIT]
  1. ; This code was written by Semantic Microsystems, Inc.
  2. ; which has placed it in the public domain.
  3.  
  4. ; Pre-release version of the file ":Examples:texteditor.sch"
  5. ; from MacScheme+Toolsmith™
  6.  
  7. ; A simple editing application.
  8.  
  9. (begin (set! include-source-code? #f)
  10.        (set! include-lambda-list? #f))
  11.  
  12. (begin (load ":Chapters:chap20.data")
  13.        (load ":Chapters:chap20.traps")
  14.        (load ":Chapters:v2.chap4.data")
  15.        (load ":Chapters:v2.chap4.traps")
  16.        (load ":Chapters:chap7.traps")
  17.        (load ":Examples:fs.sch")
  18.        (load ":Examples:files.sch")
  19.        (load ":Examples:fonts.sch")
  20.        (load ":Examples:search.sch")
  21.        (load ":Examples:linker.sch"))
  22.  
  23. (define (main)
  24.   (begin-application)
  25.   (hidewindow ((lookup-window-object (frontwindow)) 'windowptr))
  26.   (pushmenubar)
  27.   (init-search)
  28.   (setup-menus)
  29.   (begin-tasking)
  30.   (start-task idle-loop)
  31.   (start-task relaxation-loop)
  32.   (kill-current-task))
  33.  
  34. (define (setup-menus)
  35.   (setup-apple-menu)
  36.   (setup-file-menu)
  37.   (setup-edit-menu)
  38.   (setup-font-menu)
  39.   (setup-search-menu))
  40.  
  41. (define (setup-apple-menu)
  42.   (let ((applemenu (make-menu (list->string (list applmark)))))
  43.     (applemenu 'addresources
  44.                (make%restype "DRVR")
  45.                (lambda (n)
  46.                  (lambda ()
  47.                    (let ((temp (newptr 256)))
  48.                      (getitem (applemenu 'menuhandle) n temp)
  49.                      (opendeskacc temp)
  50.                      (disposptr temp)))))))
  51.  
  52. (define (setup-file-menu)
  53.   (let ((filemenu (make-menu "File")))
  54.     (filemenu 'append
  55.               "New"
  56.               (lambda () (make-document "Untitled" #f)))
  57.     (filemenu 'append
  58.               "Open..."
  59.               (lambda ()
  60.                 (let ((info (stdgetfile 60 60 "TEXT")))
  61.                   (let ((flag (car info))
  62.                         (name (cadr info))
  63.                         (vrefnum (caddr info)))
  64.                     (if flag
  65.                         (let ((d (make-document name vrefnum))
  66.                               (contents (read-file name vrefnum)))
  67.                           (if contents
  68.                               ((d 'editor 'set-textstring)
  69.                                (->string contents)))))))))
  70.     (filemenu 'append
  71.               "Close"
  72.               (lambda ()
  73.                 ((lookup-document-object (FrontWindow))
  74.                  'close))
  75.               front-window-is-ours?)
  76.     (filemenu 'append
  77.               "Save"
  78.               (lambda ()
  79.                 ((lookup-document-object (FrontWindow))
  80.                  'save))
  81.               front-window-is-ours?)
  82.     (filemenu 'append
  83.               "Save as..."
  84.               (lambda ()
  85.                 ((lookup-document-object (FrontWindow))
  86.                  'save-as))
  87.               front-window-is-ours?)
  88.     (filemenu 'append "Quit" exit)))
  89.  
  90. (define (setup-edit-menu)
  91.   (let ((editmenu (make-menu "Edit")))
  92.     (editmenu 'append
  93.               "Undo/Z"
  94.               (lambda () (systemedit 0))
  95.               ; enable only if the front window is not ours
  96.               (lambda ()
  97.                 (not (front-window-is-ours?))))
  98.     (editmenu 'append
  99.               "-"
  100.               (lambda () #t)
  101.               (lambda () #f))       ; always disable
  102.     (editmenu 'append
  103.               "Cut/X"
  104.               (lambda ()
  105.                 (systemedit 2)
  106.                 ((lookup-window-object (frontwindow)) 'editor 'cut)))
  107.     (editmenu 'append
  108.               "Copy/C"
  109.               (lambda ()
  110.                 (systemedit 3)
  111.                 ((lookup-window-object (frontwindow)) 'editor 'copy)))
  112.     (editmenu 'append
  113.               "Paste/V"
  114.               (lambda ()
  115.                 (systemedit 4)
  116.                 ((lookup-window-object (frontwindow)) 'editor 'paste)))
  117.     (editmenu 'append
  118.               "Clear"
  119.               (lambda ()
  120.                 (systemedit 5)
  121.                 ((lookup-window-object (frontwindow)) 'editor 'clear)))))
  122.  
  123. (define (setup-font-menu)
  124.   (let ((fontmenu (make-menu "Font")))
  125.     (fontmenu 'addresources
  126.                (make%restype "FONT")
  127.                (lambda (n)
  128.                  (lambda ()
  129.                    (let ((temp1 (newptr 256))
  130.                          (temp2 (newptr 2)))
  131.                      (getitem (fontmenu 'menuhandle) n temp1)
  132.                      (getfnum temp1 temp2)
  133.                      (set-font (lookup-window-object (frontwindow))
  134.                                (peek.word temp2))
  135.                      (disposptr temp1)
  136.                      (disposptr temp2)))))
  137.     (fontmenu 'append
  138.               "-"
  139.               (lambda () #t)
  140.               (lambda () #f))
  141.     (for-each (lambda (size)
  142.                 (fontmenu 'append
  143.                           (number->string size)
  144.                           (lambda ()
  145.                             (set-fontsize
  146.                              (lookup-window-object (frontwindow))
  147.                              size))
  148.                           front-window-is-ours?))
  149.               '(9 10 12 14 18 24))))
  150.  
  151. (define (setup-search-menu) (make-search-menu))
  152.  
  153. ; Document objects.
  154. ;
  155. ; A document object inherits all the behavior of a window object
  156. ; but it has additional behavior when sent one of the following messages:
  157. ;
  158. ;    window
  159. ;    name
  160. ;    set-name
  161. ;    vrefnum
  162. ;    set-vrefnum
  163. ;    save
  164. ;    save-as
  165. ;    close
  166.  
  167. (define (make-document name vrefnum)
  168.   (letrec ((window (make-window 'text
  169.                                 'title name
  170.                                 'bounds 10 40 500 330))
  171.            (self
  172.             (lambda (op . args)
  173.               (if args
  174.                   (apply (self op) args)
  175.                   (case op
  176.                     ((window) window)
  177.                     ((name) name)
  178.                     ((set-name)
  179.                      (lambda (newname)
  180.                        (set! name newname)
  181.                        (let ((temp (make%string name)))
  182.                          (SetWTitle (window 'windowptr) temp)
  183.                          (disposptr temp))
  184.                        name))
  185.                     ((vrefnum) vrefnum)
  186.                     ((set-vrefnum)
  187.                      (lambda (n) (set! vrefnum n) vrefnum))
  188.                     ((save)
  189.                      (if vrefnum
  190.                          (write-file name
  191.                                      vrefnum
  192.                                      (window 'editor 'textstring)
  193.                                      "EDIT"
  194.                                      "TEXT")
  195.                          (self 'save-as)))
  196.                     ((save-as)
  197.                      (let ((info (stdputfile 60 60 name)))
  198.                        (if (car info)
  199.                            (begin
  200.                             (self 'set-name (cadr info))
  201.                             (self 'set-vrefnum (caddr info))
  202.                             (self 'save)))))
  203.                     ((close)
  204.                      (set! documents
  205.                            (remove (assq window documents) documents))
  206.                      (if (not (window 'closed?))
  207.                          (window 'close)))
  208.                     (else (window op)))))))
  209.     (set! documents (cons (list window self) documents))
  210.     self))
  211.  
  212. ; The global variable documents is an association list with elements
  213. ; of the form (<window-object> <document-object>).
  214. ; There is an entry for each window created by this application.
  215.  
  216. (define documents '())
  217.  
  218. ; Given a Toolbox windowptr such as is returned by FrontWindow,
  219. ; lookup-document-object returns the document object associated with
  220. ; it or #f if it's not ours.
  221. ; This code also redefines lookup-window-object so that it will return
  222. ; a document for those windows that have been created by this application.
  223. ; That allows documents to intercept a close message sent to a window.
  224.  
  225. (define lookup-document-object)
  226.  
  227. (let ((old-lookup-window-object lookup-window-object))
  228.   (set! lookup-document-object
  229.         (lambda (windowptr)
  230.           (let ((entry (assq (old-lookup-window-object windowptr)
  231.                              documents)))
  232.             (if entry
  233.                 (cadr entry)
  234.                 #f))))
  235.   (set! lookup-window-object
  236.         (lambda (windowptr)
  237.           (or (lookup-document-object windowptr)
  238.               (old-lookup-window-object windowptr))))
  239.   #t)
  240.  
  241. (define (front-window-is-ours?)
  242.   (lookup-document-object (frontwindow)))
  243.  
  244. ; Concurrent tasks.
  245.  
  246. (define **task-timeslice** 500)
  247.  
  248. ; This procedure soaks up idle time with occasional calls to TEIdle.
  249.  
  250. (define (idle-loop)
  251.   (call-without-interrupts
  252.    (lambda ()
  253.      (let ((texth ((lookup-window-object (FrontWindow))
  254.                    'editor
  255.                    'texthandle)))
  256.        (if texth (teidle texth)))))
  257.   (surrender-timeslice)
  258.   (idle-loop))
  259.  
  260. ; Running this procedure as a concurrent task improves interactive
  261. ; performance because
  262. ;  (1) this procedure creates no garbage whatsoever (so running
  263. ;      it as a task makes garbage collections occur less frequently);
  264. ;  (2) all pending interrupts are accepted each time through the
  265. ;      loop (because the time procedure enables interrupts).
  266.  
  267. (define (relaxation-loop)
  268.   (time)
  269.   (relaxation-loop))
  270.  
  271. ; The scheme-top-level procedure is called when MacScheme starts up.
  272.  
  273. (define (scheme-top-level)
  274.   ; exit if an error causes a reset
  275.   (set! scheme-top-level exit)
  276.   (main)
  277.   (exit))
  278.  
  279. (link-application)
  280.